home *** CD-ROM | disk | FTP | other *** search
/ PC World Komputer 2010 April / PCWorld0410.iso / hity wydania / Ubuntu 9.10 PL / karmelkowy-koliberek-desktop-9.10-i386-PL.iso / casper / filesystem.squashfs / usr / share / tcltk / tcl8.4 / package.tcl < prev    next >
Text File  |  2009-04-29  |  25KB  |  829 lines
  1. # package.tcl --
  2. #
  3. # utility procs formerly in init.tcl which can be loaded on demand
  4. # for package management.
  5. #
  6. # RCS: @(#) $Id: package.tcl,v 1.23.2.4 2006/09/22 01:26:24 andreas_kupries Exp $
  7. #
  8. # Copyright (c) 1991-1993 The Regents of the University of California.
  9. # Copyright (c) 1994-1998 Sun Microsystems, Inc.
  10. #
  11. # See the file "license.terms" for information on usage and redistribution
  12. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  13. #
  14.  
  15. # Create the package namespace
  16. namespace eval ::pkg {
  17. }
  18.  
  19. # pkg_compareExtension --
  20. #
  21. #  Used internally by pkg_mkIndex to compare the extension of a file to
  22. #  a given extension. On Windows, it uses a case-insensitive comparison
  23. #  because the file system can be file insensitive.
  24. #
  25. # Arguments:
  26. #  fileName    name of a file whose extension is compared
  27. #  ext        (optional) The extension to compare against; you must
  28. #        provide the starting dot.
  29. #        Defaults to [info sharedlibextension]
  30. #
  31. # Results:
  32. #  Returns 1 if the extension matches, 0 otherwise
  33.  
  34. proc pkg_compareExtension { fileName {ext {}} } {
  35.     global tcl_platform
  36.     if {$ext eq ""} {set ext [info sharedlibextension]}
  37.     if {$tcl_platform(platform) eq "windows"} {
  38.         return [string equal -nocase [file extension $fileName] $ext]
  39.     } else {
  40.         # Some unices add trailing numbers after the .so, so
  41.         # we could have something like '.so.1.2'.
  42.         set root $fileName
  43.         while {1} {
  44.             set currExt [file extension $root]
  45.             if {$currExt eq $ext} {
  46.                 return 1
  47.             } 
  48.  
  49.         # The current extension does not match; if it is not a numeric
  50.         # value, quit, as we are only looking to ignore version number
  51.         # extensions.  Otherwise we might return 1 in this case:
  52.         #        pkg_compareExtension foo.so.bar .so
  53.         # which should not match.
  54.  
  55.         if { ![string is integer -strict [string range $currExt 1 end]] } {
  56.         return 0
  57.         }
  58.             set root [file rootname $root]
  59.     }
  60.     }
  61. }
  62.  
  63. # pkg_mkIndex --
  64. # This procedure creates a package index in a given directory.  The
  65. # package index consists of a "pkgIndex.tcl" file whose contents are
  66. # a Tcl script that sets up package information with "package require"
  67. # commands.  The commands describe all of the packages defined by the
  68. # files given as arguments.
  69. #
  70. # Arguments:
  71. # -direct        (optional) If this flag is present, the generated
  72. #            code in pkgMkIndex.tcl will cause the package to be
  73. #            loaded when "package require" is executed, rather
  74. #            than lazily when the first reference to an exported
  75. #            procedure in the package is made.
  76. # -verbose        (optional) Verbose output; the name of each file that
  77. #            was successfully rocessed is printed out. Additionally,
  78. #            if processing of a file failed a message is printed.
  79. # -load pat        (optional) Preload any packages whose names match
  80. #            the pattern.  Used to handle DLLs that depend on
  81. #            other packages during their Init procedure.
  82. # dir -            Name of the directory in which to create the index.
  83. # args -        Any number of additional arguments, each giving
  84. #            a glob pattern that matches the names of one or
  85. #            more shared libraries or Tcl script files in
  86. #            dir.
  87.  
  88. proc pkg_mkIndex {args} {
  89.     global errorCode errorInfo
  90.     set usage {"pkg_mkIndex ?-direct? ?-lazy? ?-load pattern? ?-verbose? ?--? dir ?pattern ...?"};
  91.  
  92.     set argCount [llength $args]
  93.     if {$argCount < 1} {
  94.     return -code error "wrong # args: should be\n$usage"
  95.     }
  96.  
  97.     set more ""
  98.     set direct 1
  99.     set doVerbose 0
  100.     set loadPat ""
  101.     for {set idx 0} {$idx < $argCount} {incr idx} {
  102.     set flag [lindex $args $idx]
  103.     switch -glob -- $flag {
  104.         -- {
  105.         # done with the flags
  106.         incr idx
  107.         break
  108.         }
  109.         -verbose {
  110.         set doVerbose 1
  111.         }
  112.         -lazy {
  113.         set direct 0
  114.         append more " -lazy"
  115.         }
  116.         -direct {
  117.         append more " -direct"
  118.         }
  119.         -load {
  120.         incr idx
  121.         set loadPat [lindex $args $idx]
  122.         append more " -load $loadPat"
  123.         }
  124.         -* {
  125.         return -code error "unknown flag $flag: should be\n$usage"
  126.         }
  127.         default {
  128.         # done with the flags
  129.         break
  130.         }
  131.     }
  132.     }
  133.  
  134.     set dir [lindex $args $idx]
  135.     set patternList [lrange $args [expr {$idx + 1}] end]
  136.     if {[llength $patternList] == 0} {
  137.     set patternList [list "*.tcl" "*[info sharedlibextension]"]
  138.     }
  139.  
  140.     set oldDir [pwd]
  141.     cd $dir
  142.  
  143.     if {[catch {eval [linsert $patternList 0 glob --]} fileList]} {
  144.     global errorCode errorInfo
  145.     cd $oldDir
  146.     return -code error -errorcode $errorCode -errorinfo $errorInfo $fileList
  147.     }
  148.     foreach file $fileList {
  149.     # For each file, figure out what commands and packages it provides.
  150.     # To do this, create a child interpreter, load the file into the
  151.     # interpreter, and get a list of the new commands and packages
  152.     # that are defined.
  153.  
  154.     if {$file eq "pkgIndex.tcl"} {
  155.         continue
  156.     }
  157.  
  158.     # Changed back to the original directory before initializing the
  159.     # slave in case TCL_LIBRARY is a relative path (e.g. in the test
  160.     # suite). 
  161.  
  162.     cd $oldDir
  163.     set c [interp create]
  164.  
  165.     # Load into the child any packages currently loaded in the parent
  166.     # interpreter that match the -load pattern.
  167.  
  168.     if {$loadPat ne ""} {
  169.         if {$doVerbose} {
  170.         tclLog "currently loaded packages: '[info loaded]'"
  171.         tclLog "trying to load all packages matching $loadPat"
  172.         }
  173.         if {![llength [info loaded]]} {
  174.         tclLog "warning: no packages are currently loaded, nothing"
  175.         tclLog "can possibly match '$loadPat'"
  176.         }
  177.     }
  178.     foreach pkg [info loaded] {
  179.         if {! [string match -nocase $loadPat [lindex $pkg 1]]} {
  180.         continue
  181.         }
  182.         if {$doVerbose} {
  183.         tclLog "package [lindex $pkg 1] matches '$loadPat'"
  184.         }
  185.         if {[catch {
  186.         load [lindex $pkg 0] [lindex $pkg 1] $c
  187.         } err]} {
  188.         if {$doVerbose} {
  189.             tclLog "warning: load [lindex $pkg 0] [lindex $pkg 1]\nfailed with: $err"
  190.         }
  191.         } elseif {$doVerbose} {
  192.         tclLog "loaded [lindex $pkg 0] [lindex $pkg 1]"
  193.         }
  194.         if {[lindex $pkg 1] eq "Tk"} {
  195.         # Withdraw . if Tk was loaded, to avoid showing a window.
  196.         $c eval [list wm withdraw .]
  197.         }
  198.     }
  199.     cd $dir
  200.  
  201.     $c eval {
  202.         # Stub out the package command so packages can
  203.         # require other packages.
  204.  
  205.         rename package __package_orig
  206.         proc package {what args} {
  207.         switch -- $what {
  208.             require { return ; # ignore transitive requires }
  209.             default { uplevel 1 [linsert $args 0 __package_orig $what] }
  210.         }
  211.         }
  212.         proc tclPkgUnknown args {}
  213.         package unknown tclPkgUnknown
  214.  
  215.         # Stub out the unknown command so package can call
  216.         # into each other during their initialilzation.
  217.  
  218.         proc unknown {args} {}
  219.  
  220.         # Stub out the auto_import mechanism
  221.  
  222.         proc auto_import {args} {}
  223.  
  224.         # reserve the ::tcl namespace for support procs
  225.         # and temporary variables.  This might make it awkward
  226.         # to generate a pkgIndex.tcl file for the ::tcl namespace.
  227.  
  228.         namespace eval ::tcl {
  229.         variable file        ;# Current file being processed
  230.         variable direct        ;# -direct flag value
  231.         variable x        ;# Loop variable
  232.         variable debug        ;# For debugging
  233.         variable type        ;# "load" or "source", for -direct
  234.         variable namespaces    ;# Existing namespaces (e.g., ::tcl)
  235.         variable packages    ;# Existing packages (e.g., Tcl)
  236.         variable origCmds    ;# Existing commands
  237.         variable newCmds    ;# Newly created commands
  238.         variable newPkgs {}    ;# Newly created packages
  239.         }
  240.     }
  241.  
  242.     $c eval [list set ::tcl::file $file]
  243.     $c eval [list set ::tcl::direct $direct]
  244.  
  245.     # Download needed procedures into the slave because we've
  246.     # just deleted the unknown procedure.  This doesn't handle
  247.     # procedures with default arguments.
  248.  
  249.     foreach p {pkg_compareExtension} {
  250.         $c eval [list proc $p [info args $p] [info body $p]]
  251.     }
  252.  
  253.     if {[catch {
  254.         $c eval {
  255.         set ::tcl::debug "loading or sourcing"
  256.  
  257.         # we need to track command defined by each package even in
  258.         # the -direct case, because they are needed internally by
  259.         # the "partial pkgIndex.tcl" step above.
  260.  
  261.         proc ::tcl::GetAllNamespaces {{root ::}} {
  262.             set list $root
  263.             foreach ns [namespace children $root] {
  264.             eval [linsert [::tcl::GetAllNamespaces $ns] 0 \
  265.                 lappend list]
  266.             }
  267.             return $list
  268.         }
  269.  
  270.         # init the list of existing namespaces, packages, commands
  271.  
  272.         foreach ::tcl::x [::tcl::GetAllNamespaces] {
  273.             set ::tcl::namespaces($::tcl::x) 1
  274.         }
  275.         foreach ::tcl::x [package names] {
  276.             if {[package provide $::tcl::x] ne ""} {
  277.             set ::tcl::packages($::tcl::x) 1
  278.             }
  279.         }
  280.         set ::tcl::origCmds [info commands]
  281.  
  282.         # Try to load the file if it has the shared library
  283.         # extension, otherwise source it.  It's important not to
  284.         # try to load files that aren't shared libraries, because
  285.         # on some systems (like SunOS) the loader will abort the
  286.         # whole application when it gets an error.
  287.  
  288.         if {[pkg_compareExtension $::tcl::file [info sharedlibextension]]} {
  289.             # The "file join ." command below is necessary.
  290.             # Without it, if the file name has no \'s and we're
  291.             # on UNIX, the load command will invoke the
  292.             # LD_LIBRARY_PATH search mechanism, which could cause
  293.             # the wrong file to be used.
  294.  
  295.             set ::tcl::debug loading
  296.             load [file join . $::tcl::file]
  297.             set ::tcl::type load
  298.         } else {
  299.             set ::tcl::debug sourcing
  300.             source $::tcl::file
  301.             set ::tcl::type source
  302.         }
  303.  
  304.         # As a performance optimization, if we are creating 
  305.         # direct load packages, don't bother figuring out the 
  306.         # set of commands created by the new packages.  We 
  307.         # only need that list for setting up the autoloading 
  308.         # used in the non-direct case.
  309.         if { !$::tcl::direct } {
  310.             # See what new namespaces appeared, and import commands
  311.             # from them.  Only exported commands go into the index.
  312.             
  313.             foreach ::tcl::x [::tcl::GetAllNamespaces] {
  314.             if {! [info exists ::tcl::namespaces($::tcl::x)]} {
  315.                 namespace import -force ${::tcl::x}::*
  316.             }
  317.  
  318.             # Figure out what commands appeared
  319.             
  320.             foreach ::tcl::x [info commands] {
  321.                 set ::tcl::newCmds($::tcl::x) 1
  322.             }
  323.             foreach ::tcl::x $::tcl::origCmds {
  324.                 unset -nocomplain ::tcl::newCmds($::tcl::x)
  325.             }
  326.             foreach ::tcl::x [array names ::tcl::newCmds] {
  327.                 # determine which namespace a command comes from
  328.                 
  329.                 set ::tcl::abs [namespace origin $::tcl::x]
  330.                 
  331.                 # special case so that global names have no leading
  332.                 # ::, this is required by the unknown command
  333.                 
  334.                 set ::tcl::abs \
  335.                     [lindex [auto_qualify $::tcl::abs ::] 0]
  336.                 
  337.                 if {$::tcl::x ne $::tcl::abs} {
  338.                 # Name changed during qualification
  339.                 
  340.                 set ::tcl::newCmds($::tcl::abs) 1
  341.                 unset ::tcl::newCmds($::tcl::x)
  342.                 }
  343.             }
  344.             }
  345.         }
  346.  
  347.         # Look through the packages that appeared, and if there is
  348.         # a version provided, then record it
  349.  
  350.         foreach ::tcl::x [package names] {
  351.             if {[package provide $::tcl::x] ne ""
  352.                 && ![info exists ::tcl::packages($::tcl::x)]} {
  353.             lappend ::tcl::newPkgs \
  354.                 [list $::tcl::x [package provide $::tcl::x]]
  355.             }
  356.         }
  357.         }
  358.     } msg] == 1} {
  359.         set what [$c eval set ::tcl::debug]
  360.         if {$doVerbose} {
  361.         tclLog "warning: error while $what $file: $msg"
  362.         }
  363.     } else {
  364.         set what [$c eval set ::tcl::debug]
  365.         if {$doVerbose} {
  366.         tclLog "successful $what of $file"
  367.         }
  368.         set type [$c eval set ::tcl::type]
  369.         set cmds [lsort [$c eval array names ::tcl::newCmds]]
  370.         set pkgs [$c eval set ::tcl::newPkgs]
  371.         if {$doVerbose} {
  372.         if { !$direct } {
  373.             tclLog "commands provided were $cmds"
  374.         }
  375.         tclLog "packages provided were $pkgs"
  376.         }
  377.         if {[llength $pkgs] > 1} {
  378.         tclLog "warning: \"$file\" provides more than one package ($pkgs)"
  379.         }
  380.         foreach pkg $pkgs {
  381.         # cmds is empty/not used in the direct case
  382.         lappend files($pkg) [list $file $type $cmds]
  383.         }
  384.  
  385.         if {$doVerbose} {
  386.         tclLog "processed $file"
  387.         }
  388.     }
  389.     interp delete $c
  390.     }
  391.  
  392.     append index "# Tcl package index file, version 1.1\n"
  393.     append index "# This file is generated by the \"pkg_mkIndex$more\" command\n"
  394.     append index "# and sourced either when an application starts up or\n"
  395.     append index "# by a \"package unknown\" script.  It invokes the\n"
  396.     append index "# \"package ifneeded\" command to set up package-related\n"
  397.     append index "# information so that packages will be loaded automatically\n"
  398.     append index "# in response to \"package require\" commands.  When this\n"
  399.     append index "# script is sourced, the variable \$dir must contain the\n"
  400.     append index "# full path name of this file's directory.\n"
  401.  
  402.     foreach pkg [lsort [array names files]] {
  403.     set cmd {}
  404.     foreach {name version} $pkg {
  405.         break
  406.     }
  407.     lappend cmd ::pkg::create -name $name -version $version
  408.     foreach spec $files($pkg) {
  409.         foreach {file type procs} $spec {
  410.         if { $direct } {
  411.             set procs {}
  412.         }
  413.         lappend cmd "-$type" [list $file $procs]
  414.         }
  415.     }
  416.     append index "\n[eval $cmd]"
  417.     }
  418.  
  419.     set f [open pkgIndex.tcl w]
  420.     puts $f $index
  421.     close $f
  422.     cd $oldDir
  423. }
  424.  
  425. # tclPkgSetup --
  426. # This is a utility procedure use by pkgIndex.tcl files.  It is invoked
  427. # as part of a "package ifneeded" script.  It calls "package provide"
  428. # to indicate that a package is available, then sets entries in the
  429. # auto_index array so that the package's files will be auto-loaded when
  430. # the commands are used.
  431. #
  432. # Arguments:
  433. # dir -            Directory containing all the files for this package.
  434. # pkg -            Name of the package (no version number).
  435. # version -        Version number for the package, such as 2.1.3.
  436. # files -        List of files that constitute the package.  Each
  437. #            element is a sub-list with three elements.  The first
  438. #            is the name of a file relative to $dir, the second is
  439. #            "load" or "source", indicating whether the file is a
  440. #            loadable binary or a script to source, and the third
  441. #            is a list of commands defined by this file.
  442.  
  443. proc tclPkgSetup {dir pkg version files} {
  444.     global auto_index
  445.  
  446.     package provide $pkg $version
  447.     foreach fileInfo $files {
  448.     set f [lindex $fileInfo 0]
  449.     set type [lindex $fileInfo 1]
  450.     foreach cmd [lindex $fileInfo 2] {
  451.         if {$type eq "load"} {
  452.         set auto_index($cmd) [list load [file join $dir $f] $pkg]
  453.         } else {
  454.         set auto_index($cmd) [list source [file join $dir $f]]
  455.         } 
  456.     }
  457.     }
  458. }
  459.  
  460. # tclPkgUnknown --
  461. # This procedure provides the default for the "package unknown" function.
  462. # It is invoked when a package that's needed can't be found.  It scans
  463. # the auto_path directories and their immediate children looking for
  464. # pkgIndex.tcl files and sources any such files that are found to setup
  465. # the package database.  (On the Macintosh we also search for pkgIndex
  466. # TEXT resources in all files.)  As it searches, it will recognize changes
  467. # to the auto_path and scan any new directories.
  468. #
  469. # Arguments:
  470. # name -        Name of desired package.  Not used.
  471. # version -        Version of desired package.  Not used.
  472. # exact -        Either "-exact" or omitted.  Not used.
  473.  
  474.  
  475. proc tclPkgUnknown [expr {
  476.               [info exists tcl_platform(tip,268)]
  477.               ? "name args"
  478.               : "name version {exact {}}"
  479.               }] {
  480.     global auto_path env
  481.  
  482.     if {![info exists auto_path]} {
  483.     return
  484.     }
  485.     # Cache the auto_path, because it may change while we run through
  486.     # the first set of pkgIndex.tcl files
  487.     set old_path [set use_path $auto_path]
  488.     while {[llength $use_path]} {
  489.     set dir [lindex $use_path end]
  490.     
  491.     # Make sure we only scan each directory one time.
  492.     if {[info exists tclSeenPath($dir)]} {
  493.         set use_path [lrange $use_path 0 end-1]
  494.         continue
  495.     }
  496.     set tclSeenPath($dir) 1
  497.  
  498.     # we can't use glob in safe interps, so enclose the following
  499.     # in a catch statement, where we get the pkgIndex files out
  500.     # of the subdirectories
  501.     catch {
  502.         foreach file [glob -directory $dir -join -nocomplain \
  503.             * pkgIndex.tcl] {
  504.         set dir [file dirname $file]
  505.         if {![info exists procdDirs($dir)] && [file readable $file]} {
  506.             if {[catch {source $file} msg]} {
  507.             tclLog "error reading package index file $file: $msg"
  508.             } else {
  509.             set procdDirs($dir) 1
  510.             }
  511.         }
  512.         }
  513.     }
  514.     set dir [lindex $use_path end]
  515.     if {![info exists procdDirs($dir)]} {
  516.         set file [file join $dir pkgIndex.tcl]
  517.         # safe interps usually don't have "file readable", 
  518.         # nor stderr channel
  519.         if {([interp issafe] || [file readable $file])} {
  520.         if {[catch {source $file} msg] && ![interp issafe]}  {
  521.             tclLog "error reading package index file $file: $msg"
  522.         } else {
  523.             set procdDirs($dir) 1
  524.         }
  525.         }
  526.     }
  527.  
  528.     set use_path [lrange $use_path 0 end-1]
  529.  
  530.     # Check whether any of the index scripts we [source]d above
  531.     # set a new value for $::auto_path.  If so, then find any
  532.     # new directories on the $::auto_path, and lappend them to
  533.     # the $use_path we are working from.  This gives index scripts
  534.     # the (arguably unwise) power to expand the index script search
  535.     # path while the search is in progress.
  536.     set index 0
  537.     if {[llength $old_path] == [llength $auto_path]} {
  538.         foreach dir $auto_path old $old_path {
  539.         if {$dir ne $old} {
  540.             # This entry in $::auto_path has changed.
  541.             break
  542.         }
  543.         incr index
  544.         }
  545.     }
  546.  
  547.     # $index now points to the first element of $auto_path that
  548.     # has changed, or the beginning if $auto_path has changed length
  549.     # Scan the new elements of $auto_path for directories to add to
  550.     # $use_path.  Don't add directories we've already seen, or ones
  551.     # already on the $use_path.
  552.     foreach dir [lrange $auto_path $index end] {
  553.         if {![info exists tclSeenPath($dir)] 
  554.             && ([lsearch -exact $use_path $dir] == -1) } {
  555.         lappend use_path $dir
  556.         }
  557.     }
  558.     set old_path $auto_path
  559.     }
  560. }
  561.  
  562. # tcl::MacOSXPkgUnknown --
  563. # This procedure extends the "package unknown" function for MacOSX.
  564. # It scans the Resources/Scripts directories of the immediate children
  565. # of the auto_path directories for pkgIndex files.
  566. # Only installed in interps that are not safe so we don't check
  567. # for [interp issafe] as in tclPkgUnknown.
  568. #
  569. # Arguments:
  570. # original -        original [package unknown] procedure
  571. # name -        Name of desired package.  Not used.
  572. #ifndef TCL_TIP268
  573. # version -        Version of desired package.  Not used.
  574. # exact -        Either "-exact" or omitted.  Not used.
  575. #else
  576. # args -        List of requirements. Not used.
  577. #endif
  578.  
  579. if {[info exists tcl_platform(tip,268)]} {
  580.     proc tcl::MacOSXPkgUnknown {original name args} {
  581.     #  First do the cross-platform default search
  582.     uplevel 1 $original [linsert $args 0 $name]
  583.  
  584.     # Now do MacOSX specific searching
  585.     global auto_path
  586.  
  587.     if {![info exists auto_path]} {
  588.         return
  589.     }
  590.     # Cache the auto_path, because it may change while we run through
  591.     # the first set of pkgIndex.tcl files
  592.     set old_path [set use_path $auto_path]
  593.     while {[llength $use_path]} {
  594.         set dir [lindex $use_path end]
  595.         # get the pkgIndex files out of the subdirectories
  596.         foreach file [glob -directory $dir -join -nocomplain \
  597.                   * Resources Scripts pkgIndex.tcl] {
  598.         set dir [file dirname $file]
  599.         if {[file readable $file] && ![info exists procdDirs($dir)]} {
  600.             if {[catch {source $file} msg]} {
  601.             tclLog "error reading package index file $file: $msg"
  602.             } else {
  603.             set procdDirs($dir) 1
  604.             }
  605.         }
  606.         }
  607.         set use_path [lrange $use_path 0 end-1]
  608.         if {$old_path ne $auto_path} {
  609.         foreach dir $auto_path {
  610.             lappend use_path $dir
  611.         }
  612.         set old_path $auto_path
  613.         }
  614.     }
  615.     }
  616. } else {
  617.     proc tcl::MacOSXPkgUnknown {original name version {exact {}}} {
  618.  
  619.     #  First do the cross-platform default search
  620.     uplevel 1 $original [list $name $version $exact]
  621.  
  622.     # Now do MacOSX specific searching
  623.     global auto_path
  624.  
  625.     if {![info exists auto_path]} {
  626.         return
  627.     }
  628.     # Cache the auto_path, because it may change while we run through
  629.     # the first set of pkgIndex.tcl files
  630.     set old_path [set use_path $auto_path]
  631.     while {[llength $use_path]} {
  632.         set dir [lindex $use_path end]
  633.         # get the pkgIndex files out of the subdirectories
  634.         foreach file [glob -directory $dir -join -nocomplain \
  635.                   * Resources Scripts pkgIndex.tcl] {
  636.         set dir [file dirname $file]
  637.         if {[file readable $file] && ![info exists procdDirs($dir)]} {
  638.             if {[catch {source $file} msg]} {
  639.             tclLog "error reading package index file $file: $msg"
  640.             } else {
  641.             set procdDirs($dir) 1
  642.             }
  643.         }
  644.         }
  645.         set use_path [lrange $use_path 0 end-1]
  646.         if {$old_path ne $auto_path} {
  647.         foreach dir $auto_path {
  648.             lappend use_path $dir
  649.         }
  650.         set old_path $auto_path
  651.         }
  652.     }
  653.     }
  654. }
  655.  
  656. # tcl::MacPkgUnknown --
  657. # This procedure extends the "package unknown" function for Mac.
  658. # It searches for pkgIndex TEXT resources in all files
  659. # Only installed in interps that are not safe so we don't check
  660. # for [interp issafe] as in tclPkgUnknown.
  661. #
  662. # Arguments:
  663. # original -        original [package unknown] procedure
  664. # name -        Name of desired package.  Not used.
  665. # version -        Version of desired package.  Not used.
  666. # exact -        Either "-exact" or omitted.  Not used.
  667.  
  668. proc tcl::MacPkgUnknown {original name version {exact {}}} {
  669.  
  670.     #  First do the cross-platform default search
  671.     uplevel 1 $original [list $name $version $exact]
  672.  
  673.     # Now do Mac specific searching
  674.     global auto_path
  675.  
  676.     if {![info exists auto_path]} {
  677.     return
  678.     }
  679.     # Cache the auto_path, because it may change while we run through
  680.     # the first set of pkgIndex.tcl files
  681.     set old_path [set use_path $auto_path]
  682.     while {[llength $use_path]} {
  683.     # We look for pkgIndex TEXT resources in the resource fork of shared libraries
  684.     set dir [lindex $use_path end]
  685.     foreach x [concat [list $dir] [glob -directory $dir -nocomplain *] ] {
  686.         if {[file isdirectory $x] && ![info exists procdDirs($x)]} {
  687.         set dir $x
  688.         foreach x [glob -directory $dir -nocomplain *.shlb] {
  689.             if {[file isfile $x]} {
  690.             set res [resource open $x]
  691.             foreach y [resource list TEXT $res] {
  692.                 if {$y eq "pkgIndex"} {source -rsrc pkgIndex}
  693.             }
  694.             catch {resource close $res}
  695.             }
  696.         }
  697.         set procdDirs($dir) 1
  698.         }
  699.     }
  700.     set use_path [lrange $use_path 0 end-1]
  701.     if {$old_path ne $auto_path} {
  702.         foreach dir $auto_path {
  703.         lappend use_path $dir
  704.         }
  705.         set old_path $auto_path
  706.     }
  707.     }
  708. }
  709.  
  710. # ::pkg::create --
  711. #
  712. #    Given a package specification generate a "package ifneeded" statement
  713. #    for the package, suitable for inclusion in a pkgIndex.tcl file.
  714. #
  715. # Arguments:
  716. #    args        arguments used by the create function:
  717. #            -name        packageName
  718. #            -version    packageVersion
  719. #            -load        {filename ?{procs}?}
  720. #            ...
  721. #            -source        {filename ?{procs}?}
  722. #            ...
  723. #
  724. #            Any number of -load and -source parameters may be
  725. #            specified, so long as there is at least one -load or
  726. #            -source parameter.  If the procs component of a 
  727. #            module specifier is left off, that module will be
  728. #            set up for direct loading; otherwise, it will be
  729. #            set up for lazy loading.  If both -source and -load
  730. #            are specified, the -load'ed files will be loaded 
  731. #            first, followed by the -source'd files.
  732. #
  733. # Results:
  734. #    An appropriate "package ifneeded" statement for the package.
  735.  
  736. proc ::pkg::create {args} {
  737.     append err(usage) "[lindex [info level 0] 0] "
  738.     append err(usage) "-name packageName -version packageVersion"
  739.     append err(usage) "?-load {filename ?{procs}?}? ... "
  740.     append err(usage) "?-source {filename ?{procs}?}? ..."
  741.  
  742.     set err(wrongNumArgs) "wrong # args: should be \"$err(usage)\""
  743.     set err(valueMissing) "value for \"%s\" missing: should be \"$err(usage)\""
  744.     set err(unknownOpt)   "unknown option \"%s\": should be \"$err(usage)\""
  745.     set err(noLoadOrSource) "at least one of -load and -source must be given"
  746.  
  747.     # process arguments
  748.     set len [llength $args]
  749.     if { $len < 6 } {
  750.     error $err(wrongNumArgs)
  751.     }
  752.     
  753.     # Initialize parameters
  754.     set opts(-name)        {}
  755.     set opts(-version)        {}
  756.     set opts(-source)        {}
  757.     set opts(-load)        {}
  758.  
  759.     # process parameters
  760.     for {set i 0} {$i < $len} {incr i} {
  761.     set flag [lindex $args $i]
  762.     incr i
  763.     switch -glob -- $flag {
  764.         "-name"        -
  765.         "-version"        {
  766.         if { $i >= $len } {
  767.             error [format $err(valueMissing) $flag]
  768.         }
  769.         set opts($flag) [lindex $args $i]
  770.         }
  771.         "-source"        -
  772.         "-load"        {
  773.         if { $i >= $len } {
  774.             error [format $err(valueMissing) $flag]
  775.         }
  776.         lappend opts($flag) [lindex $args $i]
  777.         }
  778.         default {
  779.         error [format $err(unknownOpt) [lindex $args $i]]
  780.         }
  781.     }
  782.     }
  783.  
  784.     # Validate the parameters
  785.     if { [llength $opts(-name)] == 0 } {
  786.     error [format $err(valueMissing) "-name"]
  787.     }
  788.     if { [llength $opts(-version)] == 0 } {
  789.     error [format $err(valueMissing) "-version"]
  790.     }
  791.     
  792.     if { [llength $opts(-source)] == 0 && [llength $opts(-load)] == 0 } {
  793.     error $err(noLoadOrSource)
  794.     }
  795.  
  796.     # OK, now everything is good.  Generate the package ifneeded statment.
  797.     set cmdline "package ifneeded $opts(-name) $opts(-version) "
  798.     
  799.     set cmdList {}
  800.     set lazyFileList {}
  801.  
  802.     # Handle -load and -source specs
  803.     foreach key {load source} {
  804.     foreach filespec $opts(-$key) {
  805.         foreach {filename proclist} {{} {}} {
  806.         break
  807.         }
  808.         foreach {filename proclist} $filespec {
  809.         break
  810.         }
  811.         
  812.         if { [llength $proclist] == 0 } {
  813.         set cmd "\[list $key \[file join \$dir [list $filename]\]\]"
  814.         lappend cmdList $cmd
  815.         } else {
  816.         lappend lazyFileList [list $filename $key $proclist]
  817.         }
  818.     }
  819.     }
  820.  
  821.     if { [llength $lazyFileList] > 0 } {
  822.     lappend cmdList "\[list tclPkgSetup \$dir $opts(-name)\
  823.         $opts(-version) [list $lazyFileList]\]"
  824.     }
  825.     append cmdline [join $cmdList "\\n"]
  826.     return $cmdline
  827. }
  828.  
  829.